home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / dbfile.pqs / dbfiles.pas
Encoding:
Pascal/Delphi Source File  |  1985-09-09  |  28.8 KB  |  846 lines
  1. program dbfiles;
  2.  
  3.     label
  4.         stop;
  5.  
  6.     type
  7.         AnyString = string [255];
  8.         FileName = string [11];
  9.  
  10.     var
  11.         NEW_FILE_NAME, File_Name: string [11];
  12.  
  13.         f, f1, f2: Text;
  14.  
  15.         NL, Line: string [255];
  16.         X1, z, i, j, k, SpaceCount: integer;
  17.         ch: char;
  18.         texton: boolean;
  19.         Get_File: string [11];
  20.  
  21.  
  22.     function Exist(FileN: Anystring): boolean;
  23.  
  24.         var
  25.             F: file;
  26.         begin
  27.             {$I-}
  28.             assign(F, FileN);
  29.             reset(F);
  30.             {$I+}
  31.             if IOResult <> 0 then
  32.                 Exist := false
  33.             else
  34.                 Exist := true;
  35.         end;
  36.  
  37.  
  38.     Procedure Check_It;
  39.         begin
  40.             NL := '';
  41.             j := 0;
  42.             if (copy(line, 1, 4) = 'STOR') then
  43.                 begin
  44.                 NL := NL + 'STORE';
  45.                 j := 4;
  46.                 end
  47.             else if (copy(line, 1, 4) = 'ENDI') then
  48.                 begin
  49.                 NL := NL + 'ENDIF';
  50.                 j := 4;
  51.                 end
  52.             else if (Copy(line, 1, 9) = 'APPE BLAN') then
  53.                 begin
  54.                 NL := NL + 'APPEND BLANK';
  55.                 j := 9;
  56.                 end
  57.             else if (Copy(line, 1, 4) = 'ACCE') then
  58.                 begin
  59.                 NL := NL + 'ACCEPT';
  60.                 j := 4;
  61.                 end
  62.             else if (copy(line, 1, 4) = 'DELE') then
  63.                 begin
  64.                 NL := NL + 'DELETE';
  65.                 J := 4;
  66.                 end
  67.             else if (copy(line, 1, 4) = 'ENDC') then
  68.                 begin
  69.                 NL := NL + 'ENDCASE';
  70.                 j := 4;
  71.                 end
  72.             else if (copy(line, 1, 4) = 'ENDD') then
  73.                 begin
  74.                 NL := NL + 'ENDDO';
  75.                 j := 4;
  76.                 end
  77.             else if (copy(line, 1, 7) = 'DO WHIL') then
  78.                 begin
  79.                 NL := NL + 'DO WHILE';
  80.                 j := 7;
  81.                 end
  82.             else if (copy(line, 1, 4) = 'ERAS') then
  83.                 begin
  84.                 NL := NL + 'ERASE';
  85.                 j := 4;
  86.                 end
  87.             else if (copy(line, 1, 4) = 'CANC') then
  88.                 begin
  89.                 NL := NL + 'CANCEL';
  90.                 j := 4;
  91.                 end
  92.             else if (copy(line, 1, 4) = 'CLEA') then
  93.                 begin
  94.                 NL := NL + 'CLEAR';
  95.                 j := 4;
  96.                 end
  97.             else if (copy(line, 1, 4) = 'CONT') then
  98.                 begin
  99.                 NL := NL + 'CONTINUE';
  100.                 j := 4;
  101.                 end
  102.             else if (copy(line, 1, 4) = 'DISP') then
  103.                 begin
  104.                 NL := NL + 'DISPLAY';
  105.                 j := 4;
  106.                 end
  107.             else if (copy(line, 1, 4) = 'EJEC') then
  108.                 begin
  109.                 NL := NL + 'EJECT';
  110.                 j := 4;
  111.                 end
  112.             else if (copy(line, 1, 4) = 'INPU') then
  113.                 begin
  114.                 NL := NL + 'INPUT';
  115.                 j := 4
  116.                 end
  117.             else if (copy(line, 1, 4) = 'RELE') then
  118.                 begin
  119.                 NL := NL + 'RELEASE';
  120.                 j := 4;
  121.                 end
  122.             else if (copy(line, 1, 4) = 'DELE') then
  123.                 begin
  124.                 NL := NL + 'DELETE';
  125.                 j := 4;
  126.                 end
  127.             else if (copy(line, 1, 4) = 'LOCA') then
  128.                 begin
  129.                 NL := NL + 'LOCATE';
  130.                 j := 4;
  131.                 end
  132.             else if (copy(line, 1, 4) = 'RETU') then
  133.                 begin
  134.                 NL := NL + 'RETURN';
  135.                 j := 4;
  136.                 end
  137.             else if (copy(line, 1, 4) = 'REPL') then
  138.                 begin
  139.                 NL := NL + 'REPLACE';
  140.                 j := 4;
  141.                 end
  142.             else if (copy(line, 1, 4) = 'REST') then
  143.                 begin
  144.                 NL := NL + 'RESTORE';
  145.                 j := 4;
  146.                 end
  147.             else if (copy(line, 1, 9) = 'SELE PRIM') then
  148.                 begin
  149.                 NL := NL + 'SELECT PRIMARY';
  150.                 j := 9;
  151.                 end
  152.             else if (copy(line, 1, 9) = 'SELE SECO') then
  153.                 begin
  154.                 NL := NL + 'SELECT SECONDARY';
  155.                 j := 9;
  156.                 end
  157.             else if (copy(line, 1, 4) = 'CHAN') then
  158.                 begin
  159.                 NL := NL + 'CHANGE';
  160.                 j := 4;
  161.                 end
  162.             else if (copy(line, 1, 4) = 'COUN') then
  163.                 begin
  164.                 NL := NL + 'COUNT';
  165.                 j := 4;
  166.                 end
  167.             else if (copy(line, 1, 4) = 'INSE') then
  168.                 begin
  169.                 NL := NL + 'INSERT';
  170.                 j := 4;
  171.                 end
  172.             else if (copy(line, 1, 4) = 'RECA') then
  173.                 begin
  174.                 NL := NL + 'RECALL';
  175.                 j := 4;
  176.                 end
  177.             else if (copy(line, 1, 4) = 'RELE') then
  178.                 begin
  179.                 NL := NL + 'RELEASE';
  180.                 j := 4;
  181.                 end
  182.             else if (copy(line, 1, 4) = 'REPO') then
  183.                 begin
  184.                 NL := NL + 'REPORT';
  185.                 j := 4;
  186.                 end
  187.             else if (copy(line, 1, 4) = 'BROW') then
  188.                 begin
  189.                 NL := NL + 'BROWSE';
  190.                 j := 4;
  191.                 end
  192.             else if (copy(line, 1, 4) = 'RESE') then
  193.                 begin
  194.                 NL := NL + 'RESET';
  195.                 j := 4;
  196.                 end
  197.             else if (copy(line, 1, 7) = 'TOTA ON') then
  198.                 begin
  199.                 NL := NL + 'TOTAL ON';
  200.                 j := 7;
  201.                 end
  202.             else if (copy(line, 1, 9) = 'UPDA FROM') then
  203.                 begin
  204.                 NL := NL + 'UPDATE FROM';
  205.                 j := 9;
  206.                 end;
  207.             for i := j + 1 to length(line) do
  208.                 NL := NL + line[i];
  209.             line := NL;
  210.         end;
  211.  
  212.  
  213.     Procedure Offset;
  214.  
  215.         var
  216.             tempcount: integer;
  217.  
  218.         begin
  219.             tempcount := 0;
  220.             while tempcount < Spacecount do
  221.                 begin
  222.                 write(f1, ' ');
  223.                 tempcount := tempcount + 1;
  224.                 end;
  225.         end;
  226.  
  227.  
  228.     Procedure PrintLine;
  229.         begin
  230.             if not texton then
  231.                 Offset;
  232.             writeln(f1, line);
  233.             if (copy(line, 1, 4) = 'TEXT') or (copy(line, 1, 4) = 'text') or
  234.                (copy(line, 1, 4) = 'Text') then
  235.                 texton := true;
  236.         end;
  237.  
  238.  
  239.     procedure expand_files;
  240.         var
  241.             line_count : integer;
  242.  
  243.         begin
  244.             line_count:=0;
  245.             ClrScr;
  246.             writeln('Expanding line number: ');
  247.             Assign(f, File_Name + '.PRG');
  248.             ReSet(f);
  249.             Assign(f1, File_Name + '.NEW');
  250.             Rewrite(f1);
  251.             Texton := false;
  252.             SpaceCount := 0;
  253.             While not Eof(f) do
  254.                 begin
  255.                 readln(f, Line);
  256.                 line_count:=line_count+1;
  257.                 write(line_count:4);
  258.                 Check_it;
  259.  
  260.                 if (copy(line, 1, 4) = 'ENDT') or (copy(line, 1,
  261.                    4) = 'endt') or (copy(line, 1, 7) = 'Endtext') or
  262.                    (copy(line, 1, 7) = 'ENDTEXT') or (copy(line, 1,
  263.                    7) = 'EndText') or (copy(line, 1, 7) = 'endtext') then
  264.                     texton := false;
  265.                 if copy(line, 1, 4) = 'CASE' then
  266.                     begin
  267.                     Offset;
  268.                     writeln(f1, '*');
  269.                     end;
  270.  
  271.                 if (copy(line, 1, 7) = 'DO WHIL') or (copy(line, 1,
  272.                    2) = 'IF') or (copy(line, 1, 7) = 'DO CASE') then
  273.                     begin
  274.                     Offset;
  275.                     SpaceCount := SpaceCount + 2;
  276.                     writeln(f1, line);
  277.                     end
  278.  
  279.                 else if (copy(line, 1, 4) = 'ENDC') or (copy(line, 1,
  280.                         4) = 'ENDD') or (copy(line, 1, 4) = 'ENDI') then
  281.                     begin
  282.                     SpaceCount := SpaceCount - 2;
  283.                     Offset;
  284.                     writeln(f1, line);
  285.                     end
  286.  
  287.                 else if copy(line, 1, 4) = 'ELSE' then
  288.                     begin
  289.                     SpaceCount := SpaceCount - 2;
  290.                     Offset;
  291.                     Writeln(f1, line);
  292.                     SpaceCount := SpaceCount + 2;
  293.                     end
  294.  
  295.                 else
  296.                     PrintLine;
  297.                 end;
  298.             close(f);
  299.             close(f1);
  300.             writeln;
  301.             write(chr(7));
  302.             writeln;
  303.             writeln('Your original file is stored as ',File_Name,'.PRG');
  304.             writeln('The expanded file  is stored as ',File_Name,'.NEW');
  305.             writeln;
  306.             write('Press [RETURN] to continue...');
  307.             read(kbd,ch);
  308.         end;
  309.  
  310.  
  311.     procedure compress_files;
  312.  
  313.         label
  314.             start;
  315.  
  316.         var
  317.             temp_file: string [12];
  318.             NL: string [255];
  319.             quote: boolean;
  320.             texton: boolean;
  321.             line_count : integer;
  322.  
  323.         Procedure CheckIt;
  324.             begin
  325.                 if (copy(line, j, 5) = 'store') or (copy(line, j,
  326.                    5) = 'STORE') then
  327.                     begin
  328.                     NL := NL + 'STOR';
  329.                     j := j + 5;
  330.                     end
  331.                 else if copy(line, j, 2) = 'if' then
  332.                     begin
  333.                     NL := NL + 'IF';
  334.                     j := j + 2;
  335.                     end
  336.                 else if (copy(line, j, 5) = 'endif') or (copy(line, j,
  337.                         5) = 'ENDIF') then
  338.                     begin
  339.                     NL := NL + 'ENDI';
  340.                     j := j + 5;
  341.                     end
  342.                 else if copy(line, j, 3) = 'set' then
  343.                     begin
  344.                     NL := NL + 'SET';
  345.                     j := j + 3;
  346.                     end
  347.                 else if copy(line, j, 4) = 'case' then
  348.                     begin
  349.                     NL := NL + 'CASE';
  350.                     j := j + 4;
  351.                     end
  352.                 else if (Copy(line, j, 12) = 'append blank') or (Copy(line, j,
  353.                         12) = 'APPEND BLANK') then
  354.                     begin
  355.                     NL := NL + 'APPE BLAN';
  356.                     j := j + 12;
  357.                     end
  358.                 else if (Copy(line, j, 6) = 'accept') or (Copy(line, j,
  359.                         6) = 'ACCEPT') then
  360.                     begin
  361.                     NL := NL + 'ACCE';
  362.                     j := j + 6;
  363.                     end
  364.                 else if (copy(line, j, 6) = 'delete') or (copy(line, j,
  365.                         6) = 'DELETE') then
  366.                     begin
  367.                     NL := NL + 'DELE';
  368.                     J := J + 6;
  369.                     end
  370.                 else if copy(line, j, 4) = 'edit' then
  371.                     begin
  372.                     NL := NL + 'EDIT';
  373.                     j := j + 4;
  374.                     end
  375.                 else if (copy(line, j, 7) = 'endcase') or (copy(line, j,
  376.                         7) = 'ENDCASE') then
  377.                     begin
  378.                     NL := NL + 'ENDC';
  379.                     j := j + 7;
  380.                     end
  381.                 else if (copy(line, j, 5) = 'enddo') or (copy(line, j,
  382.                         5) = 'ENDDO') then
  383.                     begin
  384.                     NL := NL + 'ENDD';
  385.                     j := j + 5;
  386.                     end
  387.                 else if (copy(line, j, 8) = 'do while') or (copy(line, j,
  388.                         8) = 'DO WHILE') then
  389.                     begin
  390.                     NL := NL + 'DO WHIL';
  391.                     j := j + 8;
  392.                     end
  393.                 else if (copy(line, j, 5) = 'erase') or (copy(line, j,
  394.                         5) = 'ERASE') then
  395.                     begin
  396.                     NL := NL + 'ERAS';
  397.                     j := j + 5;
  398.                     end
  399.                 else if (copy(line, j, 6) = 'cancel') or (copy(line, j,
  400.                         6) = 'CANCEL') then
  401.                     begin
  402.                     NL := NL + 'CANC';
  403.                     j := j + 6;
  404.                     end
  405.                 else if (copy(line, j, 5) = 'clear') or (copy(line, j,
  406.                         5) = 'CLEAR') then
  407.                     begin
  408.                     NL := NL + 'CLEA';
  409.                     j := j + 5;
  410.                     end
  411.                 else if (copy(line, j, 8) = 'continue') or (copy(line, j,
  412.                         8) = 'CONTINUE') then
  413.                     begin
  414.                     NL := NL + 'CONT';
  415.                     j := j + 8;
  416.                     end
  417.                 else if (copy(line, j, 7) = 'display') or (copy(line, j,
  418.                         7) = 'DISPLAY') then
  419.                     begin
  420.                     NL := NL + 'DISP';
  421.                     j := j + 7;
  422.                     end
  423.                 else if copy(line, j, 4) = 'else' then
  424.                     begin
  425.                     NL := NL + 'ELSE';
  426.                     j := j + 4;
  427.                     end
  428.                 else if (copy(line, j, 5) = 'eject') or (copy(line, j,
  429.                         5) = 'EJECT') then
  430.                     begin
  431.                     NL := NL + 'EJEC';
  432.                     j := j + 5;
  433.                     end
  434.                 else if (copy(line, j, 5) = 'input') or (copy(line, j,
  435.                         5) = 'INPUT') then
  436.                     begin
  437.                     NL := NL + 'INPU';
  438.                     j := j + 5;
  439.                     end
  440.                 else if (copy(line, j, 7) = 'release') or (copy(line, j,
  441.                         7) = 'RELEASE') then
  442.                     begin
  443.                     NL := NL + 'RELE';
  444.                     j := j + 7;
  445.                     end
  446.                 else if copy(line, j, 7) = 'do case' then
  447.                     begin
  448.                     NL := NL + 'DO CASE';
  449.                     j := j + 7;
  450.                     end
  451.                 else if (copy(line, j, 6) = 'delete') or (copy(line, j,
  452.                         6) = 'DELETE') then
  453.                     begin
  454.                     NL := NL + 'DELE';
  455.                     j := j + 6;
  456.                     end
  457.                 else if copy(line, j, 4) = 'find' then
  458.                     begin
  459.                     NL := NL + 'FIND';
  460.                     j := j + 4;
  461.                     end
  462.                 else if copy(line, j, 4) = 'goto' then
  463.                     begin
  464.                     NL := NL + 'GOTO';
  465.                     j := j + 4;
  466.                     end
  467.                 else if copy(line, j, 4) = 'pack' then
  468.                     begin
  469.                     NL := NL + 'PACK';
  470.                     j := j + 4;
  471.                     end
  472.                 else if (copy(line, j, 6) = 'locate') or (copy(line, j,
  473.                         6) = 'LOCATE') then
  474.                     begin
  475.                     NL := NL + 'LOCA';
  476.                     j := j + 6;
  477.                     end
  478.                 else if copy(line, j, 4) = 'loop' then
  479.                     begin
  480.                     NL := NL + 'LOOP';
  481.                     j := j + 4;
  482.                     end
  483.                 else if copy(line, j, 4) = 'skip' then
  484.                     begin
  485.                     NL := NL + 'SKIP';
  486.                     j := j + 4;
  487.                     end
  488.                 else if (copy(line, j, 6) = 'return') or (copy(line, j,
  489.                         6) = 'RETURN') then
  490.                     begin
  491.                     NL := NL + 'RETU';
  492.                     j := j + 6;
  493.                     end
  494.                 else if (copy(line, j, 7) = 'replace') or (copy(line, j,
  495.                         7) = 'REPLACE') then
  496.                     begin
  497.                     NL := NL + 'REPL';
  498.                     j := j + 7;
  499.                     end
  500.                 else if (copy(line, j, 7) = 'restore') or (copy(line, j,
  501.                         7) = 'RESTORE') then
  502.                     begin
  503.                     NL := NL + 'REST';
  504.                     j := j + 7;
  505.                     end
  506.                 else if (copy(line, j, 14) = 'select primary') or (copy(line,
  507.                         j, 14) = 'SELECT PRIMARY') then
  508.                     begin
  509.                     NL := NL + 'SELE PRIM';
  510.                     j := j + 14;
  511.                     end
  512.                 else if (copy(line, j, 16) = 'select secondary') or
  513.                         (copy(line, j, 16) = 'SELECT SECONDARY') then
  514.                     begin
  515.                     NL := NL + 'SELE SECO';
  516.                     j := j + 16;
  517.                     end
  518.                 else if copy(line, j, 3) = 'use' then
  519.                     begin
  520.                     NL := NL + 'USE';
  521.                     j := j + 3;
  522.                     end
  523.                 else if (copy(line, j, 6) = 'change') or (copy(line, j,
  524.                         6) = 'CHANGE') then
  525.                     begin
  526.                     NL := NL + 'CHAN';
  527.                     j := j + 6;
  528.                     end
  529.                 else if (copy(line, j, 5) = 'count') or (copy(line, j,
  530.                         5) = 'COUNT') then
  531.                     begin
  532.                     NL := NL + 'COUN';
  533.                     j := j + 5;
  534.                     end
  535.                 else if (copy(line, j, 6) = 'insert') or (copy(line, j,
  536.                         6) = 'INSERT') then
  537.                     begin
  538.                     NL := NL + 'INSE';
  539.                     j := j + 6;
  540.                     end
  541.                 else if copy(line, j, 4) = 'list' then
  542.                     begin
  543.                     NL := NL + 'LIST';
  544.                     j := j + 4;
  545.                     end
  546.                 else if copy(line, j, 4) = 'quit' then
  547.                     begin
  548.                     NL := NL + 'QUIT';
  549.                     j := j + 4;
  550.                     end
  551.                 else if copy(line, j, 4) = 'read' then
  552.                     begin
  553.                     NL := NL + 'READ';
  554.                     j := j + 4;
  555.                     end
  556.                 else if (copy(line, j, 6) = 'recall') or (copy(line, j,
  557.                         6) = 'RECALL') then
  558.                     begin
  559.                     NL := NL + 'RECA';
  560.                     j := j + 6;
  561.                     end
  562.                 else if (copy(line, j, 7) = 'release') or (copy(line, j,
  563.                         7) = 'RELEASE') then
  564.                     begin
  565.                     NL := NL + 'RELE';
  566.                     j := j + 7;
  567.                     end
  568.                 else if (copy(line, j, 6) = 'report') or (copy(line, j,
  569.                         6) = 'REPORT') then
  570.                     begin
  571.                     NL := NL + 'REPO';
  572.                     j := j + 6;
  573.                     end
  574.                 else if copy(line, j, 4) = 'wait' then
  575.                     begin
  576.                     NL := NL + 'WAIT';
  577.                     j := j + 4;
  578.                     end
  579.                 else if (copy(line, j, 6) = 'browse') or (copy(line, j,
  580.                         6) = 'BROWSE') then
  581.                     begin
  582.                     NL := NL + 'BROW';
  583.                     j := j + 6;
  584.                     end
  585.                 else if (copy(line, j, 5) = 'reset') or (copy(line, j,
  586.                         5) = 'RESET') then
  587.                     begin
  588.                     NL := NL + 'RESE';
  589.                     j := j + 5;
  590.                     end
  591.                 else if copy(line, j, 7) = 'save to' then
  592.                     begin
  593.                     NL := NL + 'SAVE TO';
  594.                     j := j + 7;
  595.                     end
  596.                 else if copy(line, j, 7) = 'copy to' then
  597.                     begin
  598.                     NL := NL + 'COPY TO';
  599.                     j := j + 7;
  600.                     end
  601.                 else if (copy(line, j, 8) = 'total on') or (copy(line, j,
  602.                         8) = 'TOTAL ON') then
  603.                     begin
  604.                     NL := NL + 'TOTA ON';
  605.                     j := j + 8;
  606.                     end
  607.                 else if copy(line, j, 3) = 'sum' then
  608.                     begin
  609.                     NL := NL + 'SUM';
  610.                     j := j + 3;
  611.                     end
  612.                 else if copy(line, j, 7) = 'sort to' then
  613.                     begin
  614.                     NL := NL + 'SORT TO';
  615.                     j := j + 7;
  616.                     end
  617.                 else if copy(line, j, 7) = 'join to' then
  618.                     begin
  619.                     NL := NL + 'JOIN TO';
  620.                     j := j + 7;
  621.                     end
  622.                 else if (copy(line, j, 11) = 'update from') or (copy(line, j,
  623.                         11) = 'UPDATE FROM') then
  624.                     begin
  625.                     NL := NL + 'UPDA FROM';
  626.                     j := j + 11;
  627.                     end
  628.                 else if copy(line, j, 2) = 'do' then
  629.                     begin
  630.                     NL := NL + 'DO';
  631.                     j := j + 2;
  632.                     end;
  633.             end;
  634.  
  635.  
  636.         Procedure PrintLine;
  637.             begin
  638.                 for i := j to length(line) do
  639.                     NL := NL + line[i];
  640.             end;
  641.  
  642.  
  643.         Procedure IsSpace;
  644.             begin
  645.                 if (line[i + 1] = '<') or (line[i + 1] = '>') or
  646.                    (line[i + 1] = '=') or (line[i + 1] = '+') or
  647.                    (line[i + 1] = '-') or (line[i + 1] = '*') or
  648.                    (line[i + 1] = '/') or (line[i + 1] = ',') then
  649.                     i := i + 1
  650.                 else if (line[i - 1] = '<') or (line[i - 1] = '>') or
  651.                         (line[i - 1] = '=') or (line[i - 1] = '+') or
  652.                         (line[i - 1] = '-') or (line[i - 1] = '*') or
  653.                         (line[i - 1] = '/') or (line[i - 1] = ',') then
  654.                     i := i + 1;
  655.             end;
  656.  
  657.  
  658.         Procedure CommandLine;
  659.             begin
  660.                 i := j;
  661.                 quote := false;
  662.                 while i <= length(line) do
  663.                     begin
  664.                     if (quote = false) and (line[i] = chr(34)) then
  665.                         quote := true
  666.                     else if (quote = false) and (line[i] = chr(39)) then
  667.                         quote := true
  668.                     else if (quote = true) and (line[i] = chr(34)) then
  669.                         quote := false
  670.                     else if (quote = true) and (line[i] = chr(39)) then
  671.                         quote := false;
  672.                     if (quote = false) and (line[i] = chr(32)) then
  673.                         IsSpace;
  674.                     NL := NL + line[i];
  675.                     i := i + 1;
  676.                     end;
  677.             end;
  678.  
  679.         begin
  680.             ClrScr;
  681.             line_count:=0;
  682.             writeln('Compressing line number: ');
  683.             texton := false;
  684.             Assign(f, File_Name + '.PRG');
  685.             ReSet(f);
  686.             Assign(f1, File_Name + '.HLD');
  687.             Rewrite(f1);
  688.             Temp_File := File_Name + '.OLD';
  689.             If exist(Temp_File) then
  690.                 begin
  691.                 Assign(f2, Temp_file);
  692.                 Erase(f2);
  693.                 end;
  694.             start:
  695.               While not Eof(f) do
  696.                   begin
  697.                   readln(f, Line);
  698.                   line_count:=line_count+1;
  699.                   write(line_count:4);
  700.                   if Line = '' then
  701.                       goto start; ;
  702.                   j := 0;
  703.                   repeat
  704.                       j := j + 1;
  705.                   until line[j] <> ' ';
  706.                   if line[j] = '*' then
  707.                       goto start;
  708.                   if (copy(line, j, 4) = 'TEXT') or (copy(line, j,
  709.                      4) = 'text') then
  710.                       begin
  711.                       texton := true;
  712.                       writeln(f1, 'TEXT');
  713.                       goto start;
  714.                       end;
  715.                   if texton then
  716.                       if (copy(line, j, 7) = 'ENDTEXT') or (copy(line, j,
  717.                          7) = 'endtext') or (copy(line, j, 4) = 'ENDT') or
  718.                          (copy(line, j, 4) = 'endt') then
  719.                           begin
  720.                           texton := false;
  721.                           writeln(f1, 'ENDT');
  722.                           goto start;
  723.                           end
  724.                       else
  725.                           writeln(f1, line);
  726.  
  727.                   if not texton then
  728.                       begin
  729.                       NL := '';
  730.                       checkit;
  731.                       CommandLine;
  732.                       writeln(f1, NL);
  733.                       end;
  734.                   end;
  735.               write(f1, ^Z);
  736.               Close(f1);
  737.               close(f);
  738.               ReName(f, File_Name + '.OLD');
  739.               ReName(f1, File_Name + '.PRG');
  740.               writeln;
  741.               writeln;
  742.               write(chr(7));
  743.               writeln('Your original file is stored as ',File_Name,'.OLD');
  744.               writeln('The compressed file is now ',File_Name,'.PRG');
  745.               writeln;
  746.               write('Press [RETURN] to continue...');
  747.               read(kbd,ch);
  748.             end;
  749.  
  750.  
  751.         procedure help_dbfiles;
  752.             begin
  753.                 ClrScr;
  754.                 writeln;
  755.                 writeln(
  756.      'DBFILES.PAS  -   a  program to compress dBase II files and restore them'
  757.                         );
  758.                 writeln(
  759.      '                 back to a readable state. The program is a joining  of'
  760.                         );
  761.                 writeln(
  762.      '                 COMPDB.PAS and UNCOMPDB.PAS that I placed  on  several'
  763.                         );
  764.                 writeln('                 R/CPM systems.');
  765.                 writeln;
  766.                 writeln('[E]xpand.');
  767.                 writeln;
  768.                 writeln(
  769.     'This option will expand an  a  file  that has  been compressed  with the'
  770.                         );
  771.                 writeln(
  772.     '[C] option. Proper indentation will be made and all abbreviated commands'
  773.                         );
  774.                 writeln(
  775.     'will be  changed  to  their original  state  i.e.  APPE BLAN will become'
  776.                         );
  777.                 writeln('APPEND BLANK.');
  778.                 writeln;
  779.                 writeln('[C]ompress.');
  780.                 writeln;
  781.                 writeln(
  782.    'This option will compress a  dBase II command file. It eliminates spaces,'
  783.                         );
  784.                 writeln(
  785.     'comment lines and abbreviates dBase II commands to four characters. This'
  786.                         );
  787.                 writeln(
  788.     'give you a slight increase in  speed and  a considerable savings in disk'
  789.                         );
  790.                 writeln('space.');
  791.                 writeln;
  792.                 writeln;
  793.                 writeln('Dave McCourt Williamsport Pa.');
  794.                 writeln;
  795.                 writeln('Press Return to continue...');
  796.                 read(ch);
  797.             end;
  798.  
  799.  
  800.         procedure Main_Page;
  801.             begin
  802.                 ClrScr;
  803.                 gotoXY(15, 5);
  804.                 write('dBase file compander...by Dave McCourt');
  805.  
  806.                 gotoXY(15, 10);
  807.                 write('Enter file name [max 8 char no file extent] ');
  808.                 gotoXY(15, 11);
  809.                 write('The .PRG will be added to the File name.');
  810.  
  811.                 gotoXY(15, 15);
  812.                 write('[E]xpand [C]ompress [H]elp {Q}uit');
  813.                 read(kbd, ch);
  814.                 ch := UpCase(ch);
  815.                 if (ch = 'E') or (ch = 'C') then
  816.                     begin
  817.                     gotoXY(15, 13);
  818.                     write('Your file name -->:');
  819.                     read(File_Name);
  820.                     if not exist(File_Name + '.PRG') then
  821.                         begin
  822.                         gotoXY(15, 15);
  823.                         write('This file is not on this disk.        ');
  824.                         write(chr(7));
  825.                         delay(500);
  826.                         write(chr(7));
  827.                         delay(500);
  828.                         ch := ' ';
  829.                         end;
  830.                     end;
  831.             end;
  832.  
  833.         BEGIN
  834.             ch := ' ';
  835.             while ch <> 'Q' do
  836.                 begin
  837.                 Main_page;
  838.                 if ch = 'C' then
  839.                     compress_files;
  840.                 if ch = 'E' then
  841.                     expand_files;
  842.                 if ch = 'H' then
  843.                     help_dbfiles;
  844.                 end;
  845.         END.
  846.